home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / BINTOPSB.C < prev    next >
C/C++ Source or Header  |  1992-05-14  |  46KB  |  1,804 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/Bintopsb.c,v 9.51 1992/05/15 03:26:33 jinx Exp $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* This File contains the code to translate internal format binary
  36.    files to portable format. */
  37.  
  38. /* IO definitions */
  39.  
  40. #include "psbmap.h"
  41. #include "trap.h"
  42. #include "limits.h"
  43. #define internal_file input_file
  44. #define portable_file output_file
  45.  
  46. long
  47. DEFUN (Load_Data, (Count, To_Where),
  48.        long Count AND
  49.        SCHEME_OBJECT *To_Where)
  50. {
  51.   return (fread (((char *) To_Where),
  52.          (sizeof (SCHEME_OBJECT)),
  53.          Count,
  54.          internal_file));
  55. }
  56.  
  57. #define INHIBIT_FASL_VERSION_CHECK
  58. #define INHIBIT_COMPILED_VERSION_CHECK
  59. #define INHIBIT_CHECKSUMS
  60. #include "load.c"
  61. #include "bltdef.h"
  62.  
  63. /* Character macros and procedures */
  64.  
  65. extern int strlen ();
  66.  
  67. #ifndef isalpha
  68.  
  69. /* Just in case the stdio library atypically contains the character
  70.    macros, just like the C book claims. */
  71.  
  72. #include <ctype.h>
  73.  
  74. #endif /* isalpha */
  75.  
  76. #ifndef ispunct
  77.  
  78. /* This is in some libraries but not others */
  79.  
  80. static char
  81.   punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
  82.  
  83. Boolean
  84. DEFUN (ispunct, (c),
  85.        fast char c)
  86. {
  87.   fast char * s;
  88.  
  89.   s = &punctuation[0];
  90.   while (*s != '\0')
  91.   {
  92.     if (*s++ == c)
  93.     {
  94.       return (true);
  95.     }
  96.   }
  97.   return (false);
  98. }
  99.  
  100. #endif /* ispunct */
  101.  
  102. /* Global data */
  103.  
  104. /* Needed to upgrade */
  105. #define TC_PRIMITIVE_EXTERNAL    0x10
  106.  
  107. #define STRING_LENGTH_TO_LONG(value)                    \
  108.   ((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
  109.  
  110. static Boolean
  111.   allow_compiled_p = false,
  112.   allow_nmv_p = false,
  113.   shuffle_bytes_p = false,
  114.   swap_bytes_p = false,
  115.   upgrade_compiled_p = false,
  116.   upgrade_lengths_p = false,
  117.   upgrade_primitives_p = false,
  118.   upgrade_traps_p = false,
  119.   vax_invert_p = false;
  120.  
  121. static long
  122.   Heap_Relocation, Constant_Relocation,
  123.   Free, Scan, Free_Constant, Scan_Constant,
  124.   Objects, Constant_Objects;
  125.  
  126. static SCHEME_OBJECT
  127.   *Mem_Base,
  128.   *Free_Objects, *Free_Cobjects,
  129.   *compiled_entry_table, *compiled_entry_pointer,
  130.   *compiled_entry_table_end,
  131.   *primitive_table, *primitive_table_end;
  132.  
  133. static long
  134.   NFlonums,
  135.   NIntegers, NBits,
  136.   NBitstrs, NBBits,
  137.   NStrings, NChars,
  138.   NPChars;
  139.  
  140. #define OUT(s)                                \
  141. {                                    \
  142.   fprintf(portable_file, (s));                        \
  143.   break;                                \
  144. }
  145.  
  146. void
  147. DEFUN (print_a_char, (c, name),
  148.        fast char c AND
  149.        char *name)
  150. {
  151.   switch(c)
  152.   {
  153.     case '\n': OUT("\\n");
  154.     case '\t': OUT("\\t");
  155.     case '\b': OUT("\\b");
  156.     case '\r': OUT("\\r");
  157.     case '\f': OUT("\\f");
  158.     case '\\': OUT("\\\\");
  159.     case '\0': OUT("\\0");
  160.     case ' ' : OUT(" ");
  161.  
  162.     default:
  163.     if ((isascii(c)) && ((isalpha(c)) || (isdigit(c)) || (ispunct(c))))
  164.     {
  165.       putc(c, portable_file);
  166.     }
  167.     else
  168.     {
  169.       unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
  170.       fprintf(stderr,
  171.           "%s: %s: File may not be portable: c = 0x%x\n",
  172.           program_name, name, x);
  173.       /* This does not follow C conventions, but eliminates ambiguity */
  174.       fprintf(portable_file, "\\X%d ", x);
  175.     }
  176.   }
  177.   return;
  178. }
  179.  
  180. #undef MAKE_BROKEN_HEART
  181. #define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
  182.  
  183. #define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code)    \
  184. {                                    \
  185.   Old_Address += (Rel);                            \
  186.   Old_Contents = (*Old_Address);                    \
  187.   if (BROKEN_HEART_P (Old_Contents))                    \
  188.     (Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents));    \
  189.   else                                    \
  190.   {                                    \
  191.     kernel_code;                            \
  192.   }                                    \
  193. }
  194.  
  195. #define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj)    \
  196. {                                    \
  197.   (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj)));            \
  198.   {                                    \
  199.     fast long length = (OBJECT_DATUM (Old_Contents));            \
  200.     kernel_code;                            \
  201.     (*Old_Address++) = (MAKE_BROKEN_HEART (Obj));            \
  202.     (Obj) += 1;                                \
  203.     (*(FObj)++) = (MAKE_OBJECT ((type), 0));                \
  204.     (*(FObj)++) = Old_Contents;                        \
  205.     while ((length--) > 0)                        \
  206.       (*(FObj)++) = (*Old_Address++);                    \
  207.   }                                    \
  208. }
  209.  
  210. #define do_string_kernel()                        \
  211. {                                    \
  212.   NStrings += 1;                            \
  213.   NChars += (pointer_to_char (length - 1));                \
  214. }
  215.  
  216. #define do_bignum_kernel()                        \
  217. {                                    \
  218.   NIntegers += 1;                            \
  219.   NBits +=                                \
  220.     (((* ((bignum_digit_type *) (Old_Address + 1)))            \
  221.       & BIGNUM_DIGIT_MASK)                        \
  222.      * BIGNUM_DIGIT_LENGTH);                        \
  223. }
  224.  
  225. #define do_bit_string_kernel()                        \
  226. {                                    \
  227.   NBitstrs += 1;                            \
  228.   NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]);            \
  229. }
  230.  
  231. #define do_flonum_kernel(Code, Scn, Obj, FObj)                \
  232. {                                    \
  233.   (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj)));            \
  234.   NFlonums += 1;                            \
  235.   (*Old_Address++) = (MAKE_BROKEN_HEART (Obj));                \
  236.   (Obj) += 1;                                \
  237.   ALIGN_FLOAT (FObj);                            \
  238.   (*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0));            \
  239.   (* ((double *) (FObj))) = (* ((double *) Old_Address));        \
  240.   (FObj) += float_to_pointer;                        \
  241. }
  242.  
  243. #define Do_String(Code, Rel, Fre, Scn, Obj, FObj)            \
  244.   Do_Compound (Code, Rel, Fre, Scn, Obj, FObj,                \
  245.            standard_kernel (do_string_kernel (),            \
  246.                 TC_CHARACTER_STRING,            \
  247.                 Code, Scn, Obj, FObj))
  248.  
  249. #define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj)            \
  250.   Do_Compound (Code, Rel, Fre, Scn, Obj, FObj,                \
  251.            standard_kernel (do_bignum_kernel (), TC_BIG_FIXNUM,    \
  252.                 Code, Scn, Obj, FObj))
  253.  
  254. #define Do_Bit_String(Code, Rel, Fre, Scn, Obj, FObj)            \
  255.   Do_Compound (Code, Rel, Fre, Scn, Obj, FObj,                \
  256.            standard_kernel (do_bit_string_kernel (), TC_BIT_STRING,    \
  257.                 Code, Scn, Obj, FObj))
  258.  
  259. #define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj)            \
  260.   Do_Compound (Code, Rel, Fre, Scn, Obj, FObj,                \
  261.            do_flonum_kernel (Code, Scn, Obj, FObj))
  262.  
  263. void
  264. DEFUN (print_a_fixnum, (val),
  265.        long val)
  266. {
  267.   fast long size_in_bits;
  268.   fast unsigned long temp;
  269.  
  270.   temp = ((val < 0) ? -val : val);
  271.   for (size_in_bits = 0; temp != 0; size_in_bits += 1)
  272.   {
  273.     temp = temp >> 1;
  274.   }
  275.   fprintf(portable_file, "%02x %c ",
  276.       TC_FIXNUM,
  277.       (val < 0 ? '-' : '+'));
  278.   if (val == 0)
  279.   {
  280.     fprintf(portable_file, "0\n");
  281.   }
  282.   else
  283.   {
  284.     fprintf(portable_file, "%ld ", size_in_bits);
  285.     temp = ((val < 0) ? -val : val);
  286.     while (temp != 0)
  287.     {
  288.       fprintf(portable_file, "%01lx", (temp & 0xf));
  289.       temp = temp >> 4;
  290.     }
  291.     fprintf(portable_file, "\n");
  292.   }
  293.   return;
  294. }
  295.  
  296. void
  297. DEFUN (print_a_string_internal, (len, str),
  298.        fast long len AND
  299.        fast char *str)
  300. {
  301.   fprintf(portable_file, "%ld ", len);
  302.   if (shuffle_bytes_p)
  303.   {
  304.     while(len > 0)
  305.     {
  306.       print_a_char(str[3], "print_a_string");
  307.       if (len > 1)
  308.       {
  309.     print_a_char(str[2], "print_a_string");
  310.       }
  311.       if (len > 2)
  312.       {
  313.     print_a_char(str[1], "print_a_string");
  314.       }
  315.       if (len > 3)
  316.       {
  317.     print_a_char(str[0], "print_a_string");
  318.       }
  319.       len -= 4;
  320.       str += 4;
  321.     }
  322.   }
  323.   else
  324.   {
  325.     while(--len >= 0)
  326.     {
  327.       print_a_char(*str++, "print_a_string");
  328.     }
  329.   }
  330.   putc('\n', portable_file);
  331.   return;
  332. }
  333.  
  334. void
  335. DEFUN (print_a_string, (from),
  336.        SCHEME_OBJECT *from)
  337. {
  338.   long len;
  339.   long maxlen;
  340.  
  341.   maxlen = (pointer_to_char ((OBJECT_DATUM (*from++)) - 1));
  342.   len = (STRING_LENGTH_TO_LONG (*from++));
  343.  
  344.   fprintf (portable_file,
  345.        "%02x %ld ",
  346.        TC_CHARACTER_STRING,
  347.        (compact_p ? len : maxlen));
  348.  
  349.   print_a_string_internal (len, ((char *) from));
  350.   return;
  351. }
  352.  
  353. void
  354. DEFUN (print_a_primitive, (arity, length, name),
  355.        long arity AND
  356.        long length AND
  357.        char *name)
  358. {
  359.   fprintf (portable_file, "%ld ", arity);
  360.   print_a_string_internal (length, name);
  361.   return;
  362. }
  363.  
  364. static long
  365. DEFUN (bignum_length, (bignum),
  366.        SCHEME_OBJECT bignum)
  367. {
  368.   if (BIGNUM_ZERO_P (bignum))
  369.     return (0);
  370.   {
  371.     bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
  372.     fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
  373.     fast long result;
  374.     if (index >= (LONG_MAX / BIGNUM_DIGIT_LENGTH))
  375.       goto loser;
  376.     result = (index * BIGNUM_DIGIT_LENGTH);
  377.     while (digit > 0)
  378.       {
  379.     result += 1;
  380.     if (result >= LONG_MAX)
  381.       goto loser;
  382.     digit >>= 1;
  383.       }
  384.     return (result);
  385.   }
  386.  loser:
  387.   fprintf (stderr, "%s: Bignum exceeds representable length.\n",
  388.        program_name);
  389.   quit (1);
  390.   /* NOTREACHED */
  391. }
  392.  
  393. void
  394. DEFUN (print_a_bignum, (bignum_ptr),
  395.        SCHEME_OBJECT *bignum_ptr)
  396. {
  397.   SCHEME_OBJECT bignum;
  398.  
  399.   bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
  400.  
  401.   if (BIGNUM_ZERO_P (bignum))
  402.     {
  403.       fprintf (portable_file, "%02x + 0\n",
  404.            (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
  405.       return;
  406.     }
  407.   {
  408.     bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
  409.     fast long length_in_bits = (bignum_length (bignum));
  410.     fast int bits_in_digit = 0;
  411.     fast bignum_digit_type accumulator;
  412.     fprintf (portable_file, "%02x %c %ld ",
  413.          (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
  414.          ((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
  415.          length_in_bits);
  416.     accumulator = (*scan++);
  417.     bits_in_digit =
  418.       ((length_in_bits < BIGNUM_DIGIT_LENGTH)
  419.        ? length_in_bits
  420.        : BIGNUM_DIGIT_LENGTH);
  421.     while (length_in_bits > 0)
  422.       {
  423.     if (bits_in_digit > 4)
  424.       {
  425.         fprintf (portable_file, "%01lx", (accumulator & 0xf));
  426.         length_in_bits -= 4;
  427.         accumulator >>= 4;
  428.         bits_in_digit -= 4;
  429.       }
  430.     else if (bits_in_digit == 4)
  431.       {
  432.         fprintf (portable_file, "%01lx", accumulator);
  433.         length_in_bits -= 4;
  434.         if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
  435.           {
  436.         accumulator = (*scan++);
  437.         bits_in_digit = BIGNUM_DIGIT_LENGTH;
  438.           }
  439.         else if (length_in_bits > 0)
  440.           {
  441.         accumulator = (*scan++);
  442.         bits_in_digit = length_in_bits;
  443.           }
  444.         else
  445.           break;
  446.       }
  447.     else if (bits_in_digit < length_in_bits)
  448.       {
  449.         int carry = accumulator;
  450.         int diff_bits = (4 - bits_in_digit);
  451.         accumulator = (*scan++);
  452.         fprintf (portable_file, "%01lx",
  453.              (carry |
  454.               ((accumulator & ((1 << diff_bits) - 1)) <<
  455.                bits_in_digit)));
  456.         length_in_bits -= 4;
  457.         bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
  458.         if (length_in_bits >= bits_in_digit)
  459.           accumulator >>= diff_bits;
  460.         else if (length_in_bits > 0)
  461.           {
  462.         accumulator >>= diff_bits;
  463.         bits_in_digit = length_in_bits;
  464.           }
  465.         else
  466.           break;
  467.       }
  468.     else
  469.       {
  470.         fprintf (portable_file, "%01lx", accumulator);
  471.         break;
  472.       }
  473.       }
  474.   }
  475.   fprintf (portable_file, "\n");
  476. }
  477.  
  478. /* The following procedure assumes that a C long is at least 4 bits. */
  479.  
  480. void
  481. DEFUN (print_a_bit_string, (from),
  482.        SCHEME_OBJECT *from)
  483. {
  484.   SCHEME_OBJECT the_bit_string;
  485.   fast long bits_remaining, leftover_bits;
  486.   fast SCHEME_OBJECT accumulator, next_word, *scan;
  487.  
  488.   the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from));
  489.   bits_remaining = (BIT_STRING_LENGTH (the_bit_string));
  490.   fprintf(portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
  491.  
  492.   if (bits_remaining != 0)
  493.   {
  494.     fprintf(portable_file, " ");
  495.     scan = BIT_STRING_LOW_PTR(the_bit_string);
  496.     for (leftover_bits = 0;
  497.      bits_remaining > 0;
  498.      bits_remaining -= OBJECT_LENGTH)
  499.     {
  500.       next_word = *(INC_BIT_STRING_PTR(scan));
  501.  
  502.       if (bits_remaining < OBJECT_LENGTH)
  503.     next_word &= LOW_MASK(bits_remaining);
  504.  
  505.       if (leftover_bits != 0)
  506.       {
  507.     accumulator &= LOW_MASK(leftover_bits);
  508.     accumulator |=
  509.       ((next_word & LOW_MASK(4 - leftover_bits)) << leftover_bits);
  510.     next_word = (next_word >> (4 - leftover_bits));
  511.     leftover_bits += ((bits_remaining > OBJECT_LENGTH) ?
  512.               (OBJECT_LENGTH - 4) :
  513.               (bits_remaining - 4));
  514.     fprintf(portable_file, "%01lx", (accumulator & 0xf));
  515.       }
  516.       else
  517.       {
  518.     leftover_bits = ((bits_remaining > OBJECT_LENGTH) ?
  519.              OBJECT_LENGTH :
  520.              bits_remaining);
  521.       }
  522.  
  523.       for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
  524.       {
  525.     fprintf(portable_file, "%01lx", (accumulator & 0xf));
  526.     accumulator = accumulator >> 4;
  527.       }
  528.     }
  529.     if (leftover_bits != 0)
  530.     {
  531.       fprintf(portable_file, "%01lx", (accumulator & 0xf));
  532.     }
  533.   }
  534.   fprintf(portable_file, "\n");
  535.   return;
  536. }
  537.  
  538. void
  539. DEFUN (print_a_flonum, (val),
  540.        double val)
  541. {
  542.   fast long size_in_bits;
  543.   fast double mant, temp;
  544.   int expt;
  545.   extern double frexp();
  546.  
  547.   fprintf(portable_file, "%02x %c ",
  548.       TC_BIG_FLONUM,
  549.       ((val < 0.0) ? '-' : '+'));
  550.   if (val == 0.0)
  551.   {
  552.     fprintf(portable_file, "0\n");
  553.     return;
  554.   }
  555.   mant = frexp(((val < 0.0) ? -val : val), &expt);
  556.   size_in_bits = 1;
  557.  
  558.   for(temp = ((mant * 2.0) - 1.0);
  559.       temp != 0;
  560.       size_in_bits += 1)
  561.   {
  562.     temp *= 2.0;
  563.     if (temp >= 1.0)
  564.       temp -= 1.0;
  565.   }
  566.   fprintf(portable_file, "%ld %ld ", expt, size_in_bits);
  567.  
  568.   for (size_in_bits = hex_digits(size_in_bits);
  569.        size_in_bits > 0;
  570.        size_in_bits -= 1)
  571.   {
  572.     fast unsigned int digit;
  573.  
  574.     digit = 0;
  575.     for (expt = 4; --expt >= 0;)
  576.     {
  577.       mant *= 2.0;
  578.       digit = digit << 1;
  579.       if (mant >= 1.0)
  580.       {
  581.     mant -= 1.0;
  582.     digit += 1;
  583.       }
  584.     }
  585.     fprintf(portable_file, "%01x", digit);
  586.   }
  587.   putc('\n', portable_file);
  588.   return;
  589. }
  590.  
  591. /* Normal Objects */
  592.  
  593. #define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj)                \
  594. {                                    \
  595.   Old_Address += (Rel);                            \
  596.   Old_Contents = (*Old_Address);                    \
  597.   if (BROKEN_HEART_P (Old_Contents))                    \
  598.     (Mem_Base [(Scn)]) =                        \
  599.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  600.   else                                    \
  601.     {                                    \
  602.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  603.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  604.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  605.     }                                    \
  606. }
  607.  
  608. #define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj)                \
  609. {                                    \
  610.   Old_Address += (Rel);                            \
  611.   Old_Contents = (*Old_Address);                    \
  612.   if (BROKEN_HEART_P (Old_Contents))                    \
  613.     (Mem_Base [(Scn)]) =                        \
  614.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  615.   else                                    \
  616.     {                                    \
  617.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  618.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  619.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  620.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  621.     }                                    \
  622. }
  623.  
  624. #define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj)            \
  625. {                                    \
  626.   Old_Address += (Rel);                            \
  627.   Old_Contents = (*Old_Address);                    \
  628.   if (BROKEN_HEART_P (Old_Contents))                    \
  629.     (Mem_Base [(Scn)]) =                        \
  630.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  631.   else                                    \
  632.     {                                    \
  633.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  634.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  635.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  636.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  637.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  638.     }                                    \
  639. }
  640.  
  641. #define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj)                \
  642. {                                    \
  643.   Old_Address += (Rel);                            \
  644.   Old_Contents = (*Old_Address);                    \
  645.   if (BROKEN_HEART_P (Old_Contents))                    \
  646.     (Mem_Base [(Scn)]) =                        \
  647.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  648.   else                                    \
  649.     {                                    \
  650.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  651.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  652.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  653.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  654.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  655.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  656.     }                                    \
  657. }
  658.  
  659. #define Copy_Vector(Scn, Fre)                        \
  660. {                                    \
  661.   fast long len = (OBJECT_DATUM (Old_Contents));            \
  662.   (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));                \
  663.   (Mem_Base [(Fre)++]) = Old_Contents;                    \
  664.   while ((len--) > 0)                            \
  665.     (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  666. }
  667.  
  668. #define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj)            \
  669. {                                    \
  670.   Old_Address += (Rel);                            \
  671.   Old_Contents = (*Old_Address);                    \
  672.   if (BROKEN_HEART_P (Old_Contents))                    \
  673.     (Mem_Base [(Scn)]) =                        \
  674.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  675.   else                                    \
  676.     {                                    \
  677.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  678.       Copy_Vector (Scn, Fre);                        \
  679.     }                                    \
  680. }
  681.  
  682. /* This is a hack to get the cross compiler to work from vaxen to other
  683.    machines and viceversa. */
  684.  
  685. #define Do_Inverted_Block(Code, Rel, Fre, Scn, Obj, FObj)        \
  686. {                                    \
  687.   Old_Address += (Rel);                            \
  688.   Old_Contents = (*Old_Address);                    \
  689.   if (BROKEN_HEART_P (Old_Contents))                    \
  690.     (Mem_Base [(Scn)]) =                        \
  691.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  692.   else                                    \
  693.     {                                    \
  694.       fast long len1, len2;                        \
  695.       SCHEME_OBJECT * Saved;                        \
  696.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  697.       len1 = (OBJECT_DATUM (Old_Contents));                \
  698.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  699.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  700.       if ((OBJECT_TYPE (*Old_Address)) != TC_MANIFEST_NM_VECTOR)    \
  701.     {                                \
  702.       fprintf (stderr, "%s: Bad compiled code block found.\n",    \
  703.           program_name);                    \
  704.       quit (1);                            \
  705.     }                                \
  706.       len2 = (OBJECT_DATUM (*Old_Address));                \
  707.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  708.       Old_Address += len2;                        \
  709.       Saved = Old_Address;                        \
  710.       len1 -= (len2 + 1);                        \
  711.       while ((len2--) > 0)                        \
  712.     (Mem_Base [(Fre)++]) = (*--Old_Address);            \
  713.       Old_Address = Saved;                        \
  714.       while ((len1--) > 0)                        \
  715.     (Mem_Base [(Fre)++]) = (*Old_Address++);            \
  716.     }                                    \
  717. }
  718.  
  719. #ifdef HAS_COMPILER_SUPPORT
  720.  
  721. #define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj)        \
  722. {                                    \
  723.   long offset;                                \
  724.   SCHEME_OBJECT * saved;                        \
  725.   Old_Address += (Rel);                            \
  726.   saved = Old_Address;                            \
  727.   Get_Compiled_Block (Old_Address, saved);                \
  728.   Old_Contents = (*Old_Address);                    \
  729.   (Mem_Base [(Scn)]) =                            \
  730.    (MAKE_OBJECT                                \
  731.     (TC_COMPILED_ENTRY,                            \
  732.      (compiled_entry_pointer - compiled_entry_table)));            \
  733.   offset = (((char *) saved) - ((char *) Old_Address));            \
  734.   (*compiled_entry_pointer++) = (LONG_TO_FIXNUM (offset));        \
  735.   /* Base pointer */                            \
  736.   if (BROKEN_HEART_P (Old_Contents))                    \
  737.     (*compiled_entry_pointer++) =                    \
  738.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  739.   else                                    \
  740.     {                                    \
  741.       (*compiled_entry_pointer++) =                    \
  742.     (MAKE_OBJECT_FROM_OBJECTS (This, (Fre)));            \
  743.       Copy_Vector (Scn, Fre);                        \
  744.     }                                    \
  745. }
  746.  
  747. #else /* no HAS_COMPILER_SUPPORT */
  748.  
  749. #define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj)        \
  750. {                                    \
  751.   fprintf                                \
  752.     (stderr,                                \
  753.      "%s: Invoking Do_Compiled_Entry with no compiler support!\n",    \
  754.      program_name);                            \
  755.   quit (1);                                \
  756. }
  757.  
  758. #endif /* HAS_COMPILER_SUPPORT */
  759.  
  760. /* Common Pointer Code */
  761.  
  762. #define Do_Pointer(Scn, Action)                        \
  763. {                                    \
  764.   long the_datum;                            \
  765.                                     \
  766.   Old_Address = (OBJECT_ADDRESS (This));                \
  767.   the_datum = (OBJECT_DATUM (This));                    \
  768.   if ((the_datum >= Heap_Base) &&                    \
  769.       (the_datum < Dumped_Heap_Top))                    \
  770.     {                                    \
  771.       Action                                \
  772.     (HEAP_CODE, Heap_Relocation, Free,                \
  773.      Scn, Objects, Free_Objects);                    \
  774.     }                                    \
  775.   /* Currently constant space is not supported                \
  776.   else if ((the_datum >= Const_Base) &&                    \
  777.        (the_datum < Dumped_Constant_Top))                \
  778.     {                                    \
  779.       Action                                \
  780.     (CONSTANT_CODE, Constant_Relocation, Free_Constant,        \
  781.      Scn, Constant_Objects, Free_Cobjects);                \
  782.     }                                    \
  783.     */                                    \
  784.   else                                    \
  785.     {                                    \
  786.       out_of_range_pointer (This);                    \
  787.     }                                    \
  788.   (Scn) += 1;                                \
  789.   break;                                \
  790. }
  791.  
  792. void
  793. DEFUN (out_of_range_pointer, (ptr),
  794.        SCHEME_OBJECT ptr)
  795. {
  796.   fprintf(stderr,
  797.       "%s: The input file is not portable: Out of range pointer.\n",
  798.       program_name);
  799.   fprintf(stderr, "Heap_Base =  0x%lx;\tHeap_Top = 0x%lx\n",
  800.       Heap_Base, Dumped_Heap_Top);
  801.   fprintf(stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
  802.       Const_Base, Dumped_Constant_Top);
  803.   fprintf(stderr, "ptr = 0x%02x|0x%lx\n",
  804.       OBJECT_TYPE (ptr), OBJECT_DATUM (ptr));
  805.   quit(1);
  806. }
  807.  
  808. SCHEME_OBJECT *
  809. DEFUN (relocate, (object),
  810.        SCHEME_OBJECT object)
  811. {
  812.   long the_datum;
  813.   SCHEME_OBJECT *result;
  814.  
  815.   result = OBJECT_ADDRESS (object);
  816.   the_datum = OBJECT_DATUM (object);
  817.  
  818.   if ((the_datum >= Heap_Base) &&
  819.       (the_datum < Dumped_Heap_Top))
  820.   {
  821.     result += Heap_Relocation;
  822.   }
  823.  
  824. #if FALSE
  825.  
  826.   /* Currently constant space is not supported */
  827.  
  828.   else if (( the_datum >= Const_Base) &&
  829.        (the_datum < Dumped_Constant_Top))
  830.   {
  831.     result += Constant_Relocation;
  832.   }
  833.  
  834. #endif /* false */
  835.  
  836.   else
  837.   {
  838.     out_of_range_pointer(object);
  839.   }
  840.   return (result);
  841. }
  842.  
  843. /* Primitive upgrading code. */
  844.  
  845. #define PRIMITIVE_UPGRADE_SPACE 2048
  846.  
  847. static SCHEME_OBJECT
  848.   *internal_renumber_table,
  849.   *external_renumber_table,
  850.   *external_prim_name_table;
  851.  
  852. static Boolean
  853.   found_ext_prims = false;
  854.  
  855. SCHEME_OBJECT
  856. DEFUN (upgrade_primitive, (prim),
  857.        SCHEME_OBJECT prim)
  858. {
  859.   long the_datum, the_type, new_type, code;
  860.   SCHEME_OBJECT new;
  861.  
  862.   the_datum = OBJECT_DATUM (prim);
  863.   the_type = OBJECT_TYPE (prim);
  864.   if (the_type != TC_PRIMITIVE_EXTERNAL)
  865.   {
  866.     code = the_datum;
  867.     new_type = the_type;
  868.   }
  869.   else
  870.   {
  871.     found_ext_prims = true;
  872.     code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
  873.     new_type = TC_PRIMITIVE;
  874.   }
  875.  
  876.   new = internal_renumber_table[code];
  877.   if (new == SHARP_F)
  878.   {
  879.     /*
  880.       This does not need to check for overflow because the worst case
  881.       was checked in setup_primitive_upgrade;
  882.      */
  883.  
  884.     new = (MAKE_OBJECT (new_type, Primitive_Table_Length));
  885.     internal_renumber_table[code] = new;
  886.     external_renumber_table[Primitive_Table_Length] = prim;
  887.     Primitive_Table_Length += 1;
  888.     if (the_type == TC_PRIMITIVE_EXTERNAL)
  889.     {
  890.       NPChars +=
  891.     STRING_LENGTH_TO_LONG((((SCHEME_OBJECT *)
  892.                 (external_prim_name_table[the_datum]))
  893.                    [STRING_LENGTH_INDEX]));
  894.     }
  895.     else
  896.     {
  897.       NPChars += strlen(builtin_prim_name_table[the_datum]);
  898.     }
  899.     return (new);
  900.   }
  901.   else
  902.   {
  903.     return (OBJECT_NEW_TYPE (new_type, new));
  904.   }
  905. }
  906.  
  907. SCHEME_OBJECT *
  908. DEFUN (setup_primitive_upgrade, (Heap),
  909.        SCHEME_OBJECT *Heap)
  910. {
  911.   fast long count, length;
  912.   SCHEME_OBJECT *old_prims_vector;
  913.  
  914.   internal_renumber_table = &Heap[0];
  915.   external_renumber_table =
  916.     &internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
  917.   external_prim_name_table =
  918.     &external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
  919.  
  920.   old_prims_vector = relocate(Ext_Prim_Vector);
  921.   if (*old_prims_vector == SHARP_F)
  922.   {
  923.     length = 0;
  924.   }
  925.   else
  926.   {
  927.     old_prims_vector = relocate(*old_prims_vector);
  928.     length = OBJECT_DATUM (*old_prims_vector);
  929.     old_prims_vector += VECTOR_DATA;
  930.     for (count = 0; count < length; count += 1)
  931.     {
  932.       SCHEME_OBJECT *temp;
  933.  
  934.       /* symbol */
  935.       temp = relocate(old_prims_vector[count]);
  936.       /* string */
  937.       temp = relocate(temp[SYMBOL_NAME]);
  938.       external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
  939.     }
  940.   }
  941.   length += (MAX_BUILTIN_PRIMITIVE + 1);
  942.   if (length > PRIMITIVE_UPGRADE_SPACE)
  943.   {
  944.     fprintf(stderr, "%s: Too many primitives.\n", program_name);
  945.     fprintf(stderr,
  946.         "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
  947.         program_name);
  948.     quit(1);
  949.   }
  950.   for (count = 0; count < length; count += 1)
  951.   {
  952.     internal_renumber_table[count] = SHARP_F;
  953.   }
  954.   NPChars = 0;
  955.   return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
  956. }
  957.  
  958. /* Processing of a single area */
  959.  
  960. #define Do_Area(Code, Area, Bound, Obj, FObj)        \
  961.   Process_Area (Code, &Area, &Bound, &Obj, &FObj)
  962.  
  963. void
  964. DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
  965.        int Code AND
  966.        fast long *Area AND
  967.        fast long *Bound AND
  968.        fast long *Obj AND
  969.        fast SCHEME_OBJECT **FObj)
  970. {
  971.   fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
  972.  
  973.   while(*Area != *Bound)
  974.   {
  975.     This = Mem_Base[*Area];
  976.  
  977. #ifdef PRIMITIVE_EXTERNAL_REUSED
  978.     if (upgrade_primitives_p &&
  979.     (OBJECT_TYPE (This) == TC_PRIMITIVE_EXTERNAL))
  980.     {
  981.       Mem_Base[*Area] = upgrade_primitive(This);
  982.       *Area += 1;
  983.       continue;
  984.     }
  985. #endif /* PRIMITIVE_EXTERNAL_REUSED */
  986.  
  987.     Switch_by_GC_Type(This)
  988.     {
  989.  
  990. #ifndef PRIMITIVE_EXTERNAL_REUSED
  991.  
  992.       case TC_PRIMITIVE_EXTERNAL:
  993.  
  994. #endif /* PRIMITIVE_EXTERNAL_REUSED */
  995.  
  996.       case TC_PRIMITIVE:
  997.       case TC_PCOMB0:
  998.     if (upgrade_primitives_p)
  999.     {
  1000.       Mem_Base[*Area] = upgrade_primitive(This);
  1001.     }
  1002.     *Area += 1;
  1003.     break;
  1004.  
  1005.       case TC_MANIFEST_NM_VECTOR:
  1006.     nmv_p = true;
  1007.         if (null_nmv_p)
  1008.     {
  1009.       fast int i;
  1010.  
  1011.       i = OBJECT_DATUM (This);
  1012.       *Area += 1;
  1013.       for ( ; --i >= 0; *Area += 1)
  1014.       {
  1015.         Mem_Base[*Area] = SHARP_F;
  1016.       }
  1017.       break;
  1018.     }
  1019.     else if (!allow_nmv_p)
  1020.     {
  1021.       fprintf(stderr, "%s: File is not portable: NMH found\n",
  1022.           program_name);
  1023.     }
  1024.     *Area += (1 + OBJECT_DATUM (This));
  1025.     break;
  1026.  
  1027.       case TC_BROKEN_HEART:
  1028.     /* [Broken Heart 0] is the cdr of fasdumped symbols. */
  1029.     if (OBJECT_DATUM (This) != 0)
  1030.     {
  1031.       fprintf(stderr, "%s: Broken Heart found in scan.\n",
  1032.           program_name);
  1033.       quit(1);
  1034.     }
  1035.     *Area += 1;
  1036.     break;
  1037.  
  1038.       case TC_MANIFEST_CLOSURE:
  1039.       case TC_LINKAGE_SECTION:
  1040.       {
  1041.     fprintf(stderr,
  1042.         "%s: File contains linked compiled code.\n",
  1043.         program_name);
  1044.     quit(1);
  1045.       }
  1046.  
  1047.  
  1048.       case TC_COMPILED_CODE_BLOCK:
  1049.     compiled_p = true;
  1050.     if (vax_invert_p)
  1051.     {
  1052.       Do_Pointer(*Area, Do_Inverted_Block);
  1053.     }
  1054.     else if (allow_compiled_p)
  1055.     {
  1056.       Do_Pointer(*Area, Do_Vector);
  1057.     }
  1058.     else
  1059.     {
  1060.       fprintf(stderr,
  1061.           "%s: File contains compiled code.\n",
  1062.           program_name);
  1063.       quit(1);
  1064.     }
  1065.  
  1066.       case_compiled_entry_point:
  1067.     compiled_p = true;
  1068.     if (!allow_compiled_p)
  1069.     {
  1070.       fprintf(stderr,
  1071.           "%s: File contains compiled code.\n",
  1072.           program_name);
  1073.       quit(1);
  1074.     }
  1075.     Do_Pointer(*Area, Do_Compiled_Entry);
  1076.  
  1077.       case TC_STACK_ENVIRONMENT:
  1078.     fprintf(stderr,
  1079.         "%s: File contains stack environments.\n",
  1080.         program_name);
  1081.     quit(1);
  1082.  
  1083.       case TC_FIXNUM:
  1084.     NIntegers += 1;
  1085.     NBits += fixnum_to_bits;
  1086.     /* Fall Through */
  1087.  
  1088.       case TC_CHARACTER:
  1089.       Process_Character:
  1090.         Mem_Base[*Area] = (MAKE_OBJECT (Code, *Obj));
  1091.         *Obj += 1;
  1092.         **FObj = This;
  1093.         *FObj += 1;
  1094.     /* Fall through */
  1095.  
  1096.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  1097.       case_simple_Non_Pointer:
  1098.     *Area += 1;
  1099.     break;
  1100.  
  1101.       case TC_REFERENCE_TRAP:
  1102.       {
  1103.     long kind;
  1104.  
  1105.     kind = OBJECT_DATUM (This);
  1106.  
  1107.     if (upgrade_traps_p)
  1108.     {
  1109.       /* It is an old UNASSIGNED object. */
  1110.       if (kind == 0)
  1111.       {
  1112.         Mem_Base[*Area] = UNASSIGNED_OBJECT;
  1113.         *Area += 1;
  1114.         break;
  1115.       }
  1116.       if (kind == 1)
  1117.       {
  1118.         Mem_Base[*Area] = UNBOUND_OBJECT;
  1119.         *Area += 1;
  1120.         break;
  1121.       }
  1122.       fprintf(stderr,
  1123.           "%s: Bad old unassigned object. 0x%x.\n",
  1124.           program_name, This);
  1125.       quit(1);
  1126.     }
  1127.     if (kind <= TRAP_MAX_IMMEDIATE)
  1128.     {
  1129.       /* It is a non pointer. */
  1130.  
  1131.       *Area += 1;
  1132.       break;
  1133.     }
  1134.       }
  1135.       /* Fall through */
  1136.  
  1137.       case TC_WEAK_CONS:
  1138.       case_Pair:
  1139.     Do_Pointer(*Area, Do_Pair);
  1140.  
  1141.       case_Cell:
  1142.     Do_Pointer(*Area, Do_Cell);
  1143.  
  1144.       case TC_VARIABLE:
  1145.       case_Triple:
  1146.     Do_Pointer(*Area, Do_Triple);
  1147.  
  1148.       case TC_BIG_FLONUM:
  1149.     Do_Pointer(*Area, Do_Flonum);
  1150.  
  1151.       case TC_BIG_FIXNUM:
  1152.     Do_Pointer(*Area, Do_Bignum);
  1153.  
  1154.       case TC_CHARACTER_STRING:
  1155.     Do_Pointer(*Area, Do_String);
  1156.  
  1157.       case TC_ENVIRONMENT:
  1158.     if (upgrade_traps_p)
  1159.     {
  1160.       fprintf(stderr,
  1161.           "%s: Cannot upgrade environments.\n",
  1162.           program_name);
  1163.       quit(1);
  1164.     }
  1165.     /* Fall through */
  1166.  
  1167.       case TC_FUTURE:
  1168.       case_simple_Vector:
  1169.     if (BIT_STRING_P (This))
  1170.     {
  1171.       Do_Pointer(*Area, Do_Bit_String);
  1172.     }
  1173.     else
  1174.     {
  1175.       Do_Pointer(*Area, Do_Vector);
  1176.     }
  1177.  
  1178.       default:
  1179.       Bad_Type:
  1180.     fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
  1181.         program_name, OBJECT_TYPE (This));
  1182.     quit(1);
  1183.       }
  1184.   }
  1185. }
  1186.  
  1187. /* Output procedures */
  1188.  
  1189. void
  1190. DEFUN (print_external_objects, (from, count),
  1191.        fast SCHEME_OBJECT *from AND
  1192.        fast long count)
  1193. {
  1194.   while (--count >= 0)
  1195.   {
  1196.     switch(OBJECT_TYPE (*from))
  1197.     {
  1198.       case TC_FIXNUM:
  1199.     print_a_fixnum (FIXNUM_TO_LONG (*from));
  1200.     from += 1;
  1201.     break;
  1202.  
  1203.       case TC_BIT_STRING:
  1204.     print_a_bit_string (++from);
  1205.     from += (1 + (OBJECT_DATUM (*from)));
  1206.     break;
  1207.  
  1208.       case TC_BIG_FIXNUM:
  1209.     print_a_bignum (++from);
  1210.     from += (1 + (OBJECT_DATUM (*from)));
  1211.     break;
  1212.  
  1213.       case TC_CHARACTER_STRING:
  1214.     print_a_string (++from);
  1215.     from += (1 + (OBJECT_DATUM (*from)));
  1216.     break;
  1217.  
  1218.       case TC_BIG_FLONUM:
  1219.     print_a_flonum (*((double *) (from + 1)));
  1220.     from += (1 + float_to_pointer);
  1221.     break;
  1222.  
  1223.       case TC_CHARACTER:
  1224.     fprintf (portable_file, "%02x %03x\n",
  1225.          TC_CHARACTER, ((*from) & MASK_MIT_ASCII));
  1226.     from += 1;
  1227.     break;
  1228.  
  1229. #ifdef FLOATING_ALIGNMENT
  1230.  
  1231.       case TC_MANIFEST_NM_VECTOR:
  1232.         if ((OBJECT_DATUM (*from)) == 0)
  1233.     {
  1234.       from += 1;
  1235.       count += 1;
  1236.       break;
  1237.     }
  1238.         /* fall through */
  1239.  
  1240. #endif /* FLOATING_ALIGNMENT */
  1241.  
  1242.       default:
  1243.     fprintf(stderr,
  1244.         "%s: Bad Object to print externally %lx\n",
  1245.         program_name, *from);
  1246.     quit(1);
  1247.     }
  1248.   }
  1249.   return;
  1250. }
  1251.  
  1252. void
  1253. DEFUN (print_objects, (from, to),
  1254.        fast SCHEME_OBJECT *from AND
  1255.        fast SCHEME_OBJECT *to)
  1256. {
  1257.   fast long the_datum, the_type;
  1258.  
  1259.   while(from < to)
  1260.   {
  1261.  
  1262.     the_type = OBJECT_TYPE (*from);
  1263.     the_datum = OBJECT_DATUM (*from);
  1264.     from += 1;
  1265.  
  1266.     if (the_type == TC_MANIFEST_NM_VECTOR)
  1267.     {
  1268.       fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
  1269.       while (--the_datum >= 0)
  1270.       {
  1271.     fprintf(portable_file, "%lx\n", ((unsigned long) *from++));
  1272.       }
  1273.     }
  1274.     else if (the_type == TC_COMPILED_ENTRY)
  1275.     {
  1276.       SCHEME_OBJECT base;
  1277.       long offset;
  1278.  
  1279.       offset = (FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
  1280.       base = compiled_entry_table[the_datum + 1];
  1281.  
  1282.       fprintf(portable_file, "%02x %lx %02x %lx\n",
  1283.           TC_COMPILED_ENTRY, offset,
  1284.           OBJECT_TYPE (base), OBJECT_DATUM (base));
  1285.     }
  1286.     else
  1287.     {
  1288.       fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
  1289.     }
  1290.   }
  1291.   return;
  1292. }
  1293.  
  1294. /* Debugging Aids and Consistency Checks */
  1295.  
  1296. #ifdef DEBUG
  1297.  
  1298. #define DEBUGGING(action)        action
  1299.  
  1300. #define WHEN(condition, message)    when(condition, message)
  1301.  
  1302. void
  1303. DEFUN (when, (what, message),
  1304.        Boolean what AND
  1305.        char *message)
  1306. {
  1307.   if (what)
  1308.   {
  1309.     fprintf(stderr, "%s: Inconsistency: %s!\n",
  1310.         program_name, (message));
  1311.     quit(1);
  1312.   }
  1313.   return;
  1314. }
  1315.  
  1316. #define WRITE_HEADER(name, format, obj)                    \
  1317. {                                    \
  1318.   fprintf(portable_file, (format), (obj));                \
  1319.   fprintf(portable_file, "\n");                        \
  1320.   fprintf(stderr, "%s: ", (name));                    \
  1321.   fprintf(stderr, (format), (obj));                    \
  1322.   fprintf(stderr, "\n");                        \
  1323. }
  1324.  
  1325. #else /* not DEBUG */
  1326.  
  1327. #define DEBUGGING(action)
  1328.  
  1329. #define WHEN(what, message)
  1330.  
  1331. #define WRITE_HEADER(name, format, obj)                    \
  1332. {                                    \
  1333.   fprintf(portable_file, (format), (obj));                \
  1334.   fprintf(portable_file, "\n");                        \
  1335. }
  1336.  
  1337. #endif /* DEBUG */
  1338.  
  1339. /* The main program */
  1340.  
  1341. void
  1342. DEFUN_VOID (do_it)
  1343. {
  1344.   while (true)
  1345.   {
  1346.     /* Load the Data */
  1347.  
  1348.     SCHEME_OBJECT *Heap, *Storage;
  1349.     long Initial_Free;
  1350.  
  1351.     switch (Read_Header ())
  1352.     {
  1353.       /* There should really be a difference between no header
  1354.      and a short header.
  1355.        */
  1356.  
  1357.       case FASL_FILE_TOO_SHORT:
  1358.     return;
  1359.  
  1360.       case FASL_FILE_FINE:
  1361.         break;
  1362.  
  1363.       default:
  1364.         fprintf (stderr,
  1365.          "%s: Input is not a Scheme binary file.\n",
  1366.          program_name);
  1367.     quit (1);
  1368.     /* NOTREACHED */
  1369.     }
  1370.  
  1371.     if ((Version > FASL_READ_VERSION) ||
  1372.     (Version < FASL_OLDEST_VERSION) ||
  1373.     (Sub_Version > FASL_READ_SUBVERSION) ||
  1374.     (Sub_Version < FASL_OLDEST_SUBVERSION) ||
  1375.     ((Machine_Type != FASL_INTERNAL_FORMAT) &&
  1376.      (!swap_bytes_p)))
  1377.     {
  1378.       fprintf (stderr, "%s:\n", program_name);
  1379.       fprintf (stderr,
  1380.            "FASL File Version %ld Subversion %ld Machine Type %ld\n",
  1381.            Version, Sub_Version , Machine_Type);
  1382.       fprintf (stderr,
  1383.            "Expected: Version %d Subversion %d Machine Type %d\n",
  1384.            FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
  1385.       quit (1);
  1386.     }
  1387.  
  1388.     if ((((compiler_processor_type != 0) &&
  1389.       (dumped_processor_type != 0) &&
  1390.       (compiler_processor_type != dumped_processor_type)) ||
  1391.      ((compiler_interface_version != 0) &&
  1392.       (dumped_interface_version != 0) &&
  1393.       (compiler_interface_version != dumped_interface_version))) &&
  1394.     (!upgrade_compiled_p))
  1395.     {
  1396.       fprintf (stderr, "\nread_file:\n");
  1397.       fprintf (stderr,
  1398.            "FASL File: compiled code interface %4d; processor %4d.\n",
  1399.            dumped_interface_version, dumped_processor_type);
  1400.       fprintf (stderr,
  1401.            "Expected:  compiled code interface %4d; processor %4d.\n",
  1402.            compiler_interface_version, compiler_processor_type);
  1403.       quit (1);
  1404.     }
  1405.     if (compiler_processor_type != 0)
  1406.     {
  1407.       dumped_processor_type = compiler_processor_type;
  1408.     }
  1409.     if (compiler_interface_version != 0)
  1410.     {
  1411.       dumped_interface_version = compiler_interface_version;
  1412.     }
  1413.  
  1414.     /* Constant Space and bands not currently supported */
  1415.  
  1416.     if (band_p)
  1417.     {
  1418.       fprintf (stderr, "%s: Input file is a band.\n", program_name);
  1419.       quit (1);
  1420.     }
  1421.  
  1422.     if (Const_Count != 0)
  1423.     {
  1424.       fprintf (stderr,
  1425.            "%s: Input file has a constant space area.\n",
  1426.            program_name);
  1427.       quit (1);
  1428.     }
  1429.  
  1430.     shuffle_bytes_p = swap_bytes_p;
  1431.     if (Machine_Type == FASL_INTERNAL_FORMAT)
  1432.     {
  1433.       shuffle_bytes_p = false;
  1434.     }
  1435.  
  1436.     upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
  1437.     upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
  1438.     upgrade_lengths_p = upgrade_primitives_p;
  1439.  
  1440.     DEBUGGING (fprintf (stderr,
  1441.             "Dumped Heap Base = 0x%08x\n",
  1442.             Heap_Base));
  1443.  
  1444.     DEBUGGING (fprintf (stderr,
  1445.             "Dumped Constant Base = 0x%08x\n",
  1446.             Const_Base));
  1447.  
  1448.     DEBUGGING (fprintf (stderr,
  1449.             "Dumped Constant Top = 0x%08x\n",
  1450.             Dumped_Constant_Top));
  1451.  
  1452.     DEBUGGING (fprintf (stderr,
  1453.             "Heap Count = %6d\n",
  1454.             Heap_Count));
  1455.  
  1456.     DEBUGGING (fprintf (stderr,
  1457.             "Constant Count = %6d\n",
  1458.             Const_Count));
  1459.  
  1460.     {
  1461.       long Size;
  1462.  
  1463.       /* This is way larger than needed, but... what the hell? */
  1464.  
  1465.       Size = ((3 * (Heap_Count + Const_Count)) +
  1466.           (NROOTS + 1) +
  1467.           (upgrade_primitives_p ?
  1468.            (3 * PRIMITIVE_UPGRADE_SPACE) :
  1469.            Primitive_Table_Size) +
  1470.           (allow_compiled_p ?
  1471.            (2 * (Heap_Count + Const_Count)) :
  1472.            0));
  1473.  
  1474.       ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
  1475.  
  1476.       if (Heap == ((SCHEME_OBJECT *) 0))
  1477.       {
  1478.     fprintf (stderr,
  1479.          "%s: Memory Allocation Failed.  Size = %ld Scheme Objects\n",
  1480.          program_name, Size);
  1481.     quit (1);
  1482.       }
  1483.     }
  1484.  
  1485.     Storage = Heap;
  1486.     Heap += HEAP_BUFFER_SPACE;
  1487.     INITIAL_ALIGN_FLOAT (Heap);
  1488.     if ((Load_Data (Heap_Count, Heap)) != Heap_Count)
  1489.     {
  1490.       fprintf (stderr, "%s: Could not load the heap's contents.\n",
  1491.            program_name);
  1492.       quit (1);
  1493.     }
  1494.     if ((Load_Data (Const_Count, (Heap + Heap_Count))) != Const_Count)
  1495.     {
  1496.       fprintf (stderr, "%s: Could not load constant space.\n",
  1497.            program_name);
  1498.       quit (1);
  1499.     }
  1500.     Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
  1501.     Constant_Relocation = ((&Heap[Heap_Count]) -
  1502.                (OBJECT_ADDRESS (Const_Base)));
  1503.  
  1504.     /* Setup compiled code and primitive tables. */
  1505.  
  1506.     compiled_entry_table = &Heap[Heap_Count + Const_Count];
  1507.     compiled_entry_pointer = compiled_entry_table;
  1508.     compiled_entry_table_end = compiled_entry_table;
  1509.  
  1510.     if (allow_compiled_p)
  1511.     {
  1512.       compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
  1513.     }
  1514.  
  1515.     primitive_table = compiled_entry_table_end;
  1516.     if (upgrade_primitives_p)
  1517.     {
  1518.       primitive_table_end = (setup_primitive_upgrade (primitive_table));
  1519.     }
  1520.     else
  1521.     {
  1522.       fast SCHEME_OBJECT *table;
  1523.       fast long count, char_count;
  1524.  
  1525.       if ((Load_Data (Primitive_Table_Size, primitive_table)) !=
  1526.       Primitive_Table_Size)
  1527.       {
  1528.     fprintf (stderr, "%s: Could not load the primitive table.\n",
  1529.          program_name);
  1530.     quit (1);
  1531.       }
  1532.       for (char_count = 0,
  1533.        count = Primitive_Table_Length,
  1534.        table = primitive_table;
  1535.        --count >= 0;)
  1536.       {
  1537.     char_count += (STRING_LENGTH_TO_LONG (table[1 + STRING_LENGTH_INDEX]));
  1538.     table += (2 + (OBJECT_DATUM (table[1 + STRING_HEADER])));
  1539.       }
  1540.       NPChars = char_count;
  1541.       primitive_table_end = (&primitive_table[Primitive_Table_Size]);
  1542.     }
  1543.     Mem_Base = primitive_table_end;
  1544.  
  1545.     /* Reformat the data */
  1546.  
  1547.     NFlonums = NIntegers = NStrings = 0;
  1548.     NBits = NBBits = NChars = 0;
  1549.  
  1550.     Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
  1551.     Initial_Free = NROOTS;
  1552.     Scan = 0;
  1553.  
  1554.     Free = Initial_Free;
  1555.     Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
  1556.     Objects = 0;
  1557.  
  1558.     Free_Constant = (2 * Heap_Count) + Initial_Free;
  1559.     Scan_Constant = Free_Constant;
  1560.     Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
  1561.     Constant_Objects = 0;
  1562.  
  1563. #if TRUE
  1564.  
  1565.     Do_Area (HEAP_CODE, Scan, Free, Objects, Free_Objects);
  1566.  
  1567. #else
  1568.  
  1569.     /*
  1570.       When Constant Space finally becomes supported,
  1571.       something like this must be done.
  1572.       */
  1573.  
  1574.     while (true)
  1575.     {
  1576.       Do_Area (HEAP_CODE, Scan, Free,
  1577.            Objects, Free_Objects);
  1578.       Do_Area (CONSTANT_CODE, Scan_Constant, Free_Constant,
  1579.            Constant_Objects, Free_Cobjects);
  1580.       Do_Area (PURE_CODE, Scan_Pure, Free_Pure,
  1581.            Pure_Objects, Free_Pobjects);
  1582.       if (Scan == Free)
  1583.       {
  1584.     break;
  1585.       }
  1586.     }
  1587.  
  1588. #endif
  1589.  
  1590.     /* Consistency checks */
  1591.  
  1592.     WHEN (((Free - Initial_Free) > Heap_Count), "Free overran Heap");
  1593.  
  1594.     WHEN (((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
  1595.        Heap_Count),
  1596.       "Free_Objects overran Heap Object Space");
  1597.  
  1598.     WHEN (((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
  1599.       "Free_Constant overran Constant Space");
  1600.  
  1601.     WHEN (((Free_Cobjects - &Mem_Base[Initial_Free +
  1602.                       (2 * Heap_Count) + Const_Count]) >
  1603.        Const_Count),
  1604.       "Free_Cobjects overran Constant Object Space");
  1605.  
  1606.     /* Output the data */
  1607.  
  1608.     if (found_ext_prims)
  1609.     {
  1610.       fprintf (stderr, "%s:\n", program_name);
  1611.       fprintf (stderr, "NOTE: The arity of some primitives is not known.\n");
  1612.       fprintf (stderr, "      The portable file has %ld as their arity.\n",
  1613.            UNKNOWN_PRIMITIVE_ARITY);
  1614.       fprintf (stderr, "      You may want to fix this by hand.\n");
  1615.     }
  1616.  
  1617.     /* Header */
  1618.  
  1619.     WRITE_HEADER ("Portable Version", "%ld", PORTABLE_VERSION);
  1620.     WRITE_HEADER ("Machine", "%ld", FASL_INTERNAL_FORMAT);
  1621.     WRITE_HEADER ("Version", "%ld", FASL_FORMAT_VERSION);
  1622.     WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
  1623.     WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
  1624.  
  1625.     WRITE_HEADER ("Heap Count", "%ld", (Free - NROOTS));
  1626.     WRITE_HEADER ("Heap Base", "%ld", NROOTS);
  1627.     WRITE_HEADER ("Heap Objects", "%ld", Objects);
  1628.  
  1629.     /* Currently Constant and Pure not supported, but the header is ready */
  1630.  
  1631.     WRITE_HEADER ("Pure Count", "%ld", 0);
  1632.     WRITE_HEADER ("Pure Base", "%ld", Free_Constant);
  1633.     WRITE_HEADER ("Pure Objects", "%ld", 0);
  1634.  
  1635.     WRITE_HEADER ("Constant Count", "%ld", 0);
  1636.     WRITE_HEADER ("Constant Base", "%ld", Free_Constant);
  1637.     WRITE_HEADER ("Constant Objects", "%ld", 0);
  1638.  
  1639.     WRITE_HEADER ("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
  1640.  
  1641.     WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
  1642.     WRITE_HEADER ("Number of integers", "%ld", NIntegers);
  1643.     WRITE_HEADER ("Number of bits in integers", "%ld", NBits);
  1644.     WRITE_HEADER ("Number of bit strings", "%ld", NBitstrs);
  1645.     WRITE_HEADER ("Number of bits in bit strings", "%ld", NBBits);
  1646.     WRITE_HEADER ("Number of character strings", "%ld", NStrings);
  1647.     WRITE_HEADER ("Number of characters in strings", "%ld", NChars);
  1648.  
  1649.     WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
  1650.     WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
  1651.  
  1652.     if (!compiled_p)
  1653.     {
  1654.       dumped_processor_type = 0;
  1655.       dumped_interface_version = 0;
  1656.     }
  1657.  
  1658.     WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
  1659.     WRITE_HEADER ("Compiled code interface version", "%ld",
  1660.           dumped_interface_version);
  1661. #if FALSE
  1662.     WRITE_HEADER ("Compiler utilities vector", "%ld",
  1663.           (OBJECT_DATUM (dumped_utilities)));
  1664. #endif
  1665.  
  1666.     /* External Objects */
  1667.  
  1668.     print_external_objects (&Mem_Base[Initial_Free + Heap_Count],
  1669.                 Objects);
  1670.  
  1671. #if FALSE
  1672.  
  1673.     print_external_objects (&Mem_Base[Pure_Objects_Start],
  1674.                 Pure_Objects);
  1675.     print_external_objects (&Mem_Base[Constant_Objects_Start],
  1676.                 Constant_Objects);
  1677.  
  1678. #endif
  1679.  
  1680.     /* Pointer Objects */
  1681.  
  1682.     print_objects (&Mem_Base[NROOTS], &Mem_Base[Free]);
  1683.  
  1684. #if FALSE
  1685.     print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
  1686.     print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
  1687. #endif
  1688.  
  1689.     /* Primitives */
  1690.  
  1691.     if (upgrade_primitives_p)
  1692.     {
  1693.       SCHEME_OBJECT obj;
  1694.       fast SCHEME_OBJECT *table;
  1695.       fast long count, the_datum;
  1696.  
  1697.       for (count = Primitive_Table_Length,
  1698.        table = external_renumber_table;
  1699.        --count >= 0;)
  1700.       {
  1701.     obj = *table++;
  1702.     the_datum = (OBJECT_DATUM (obj));
  1703.     if ((OBJECT_TYPE (obj)) == TC_PRIMITIVE_EXTERNAL)
  1704.     {
  1705.       SCHEME_OBJECT *strobj;
  1706.  
  1707.       strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
  1708.       print_a_primitive (((long) UNKNOWN_PRIMITIVE_ARITY),
  1709.                  (STRING_LENGTH_TO_LONG
  1710.                   (strobj[STRING_LENGTH_INDEX])),
  1711.                  ((char *) &strobj[STRING_CHARS]));
  1712.     }
  1713.     else
  1714.     {
  1715.       char *str;
  1716.  
  1717.       str = builtin_prim_name_table[the_datum];
  1718.       print_a_primitive (((long) builtin_prim_arity_table[the_datum]),
  1719.                  ((long) strlen(str)),
  1720.                  str);
  1721.     }
  1722.       }
  1723.     }
  1724.     else
  1725.     {
  1726.       fast SCHEME_OBJECT *table;
  1727.       fast long count;
  1728.       long arity;
  1729.  
  1730.       for (count = Primitive_Table_Length, table = primitive_table;
  1731.        --count >= 0;)
  1732.       {
  1733.     arity = (FIXNUM_TO_LONG (*table));
  1734.     table += 1;
  1735.     print_a_primitive (arity,
  1736.                (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
  1737.                ((char *) &table[STRING_CHARS]));
  1738.     table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
  1739.       }
  1740.     }
  1741.     fflush (portable_file);
  1742.     free ((char *) Storage);
  1743.   }
  1744. }
  1745.  
  1746. /* Top Level */
  1747.  
  1748. static Boolean
  1749.   help_p = false,
  1750.   help_sup_p,
  1751.   ci_version_sup_p,
  1752.   ci_processor_sup_p;
  1753.  
  1754. /* The boolean value here is what value to store when the option is present. */
  1755.  
  1756. static struct keyword_struct
  1757.   options[] = {
  1758.     KEYWORD ("swap_bytes", &swap_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1759.     KEYWORD ("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1760.     KEYWORD ("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1761.     KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1762.     KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1763.     KEYWORD ("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1764.     KEYWORD ("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
  1765.          &ci_version_sup_p),
  1766.     KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
  1767.          &ci_processor_sup_p),
  1768.     KEYWORD ("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1769.     KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
  1770.     OUTPUT_KEYWORD (),
  1771.     INPUT_KEYWORD (),
  1772.     END_KEYWORD ()
  1773.     };
  1774.  
  1775. void
  1776. DEFUN (main, (argc, argv),
  1777.        int argc AND
  1778.        char **argv)
  1779. {
  1780.   parse_keywords (argc, argv, options, false);
  1781.  
  1782.   if (help_sup_p && help_p)
  1783.   {
  1784.     print_usage_and_exit(options, 0);
  1785.     /*NOTREACHED*/
  1786.   }
  1787.  
  1788.   upgrade_compiled_p =
  1789.     (upgrade_compiled_p || ci_version_sup_p || ci_processor_sup_p);
  1790.   allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
  1791.   allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
  1792.   if (null_nmv_p && allow_nmv_p)
  1793.   {
  1794.     fprintf (stderr,
  1795.          "%s: NMVs are both allowed and to be nulled out!\n",
  1796.          program_name);
  1797.     quit (1);
  1798.   }
  1799.  
  1800.   setup_io ("rb", "w");
  1801.   do_it ();
  1802.   quit (0);
  1803. }
  1804.